home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / units / crt.pp < prev    next >
Encoding:
Text File  |  1998-10-28  |  25.5 KB  |  1,029 lines
  1. {
  2.     $Id: crt.pp,v 1.5 1998/09/14 20:21:53 carl Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1998 by Nils Sjoholm and Carl Eric Codere
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     for details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15. {
  16.     History:
  17.  
  18.     Bugs found in delline and insline, fixed.
  19.     5 Oct 1998
  20.     nils.sjoholm@mailbox.swipnet.se
  21. }
  22.  
  23. unit Crt;
  24.  
  25. {--------------------------------------------------------------------}
  26. { LEFT TO DO:                                                        }
  27. {--------------------------------------------------------------------}
  28. { o Write special characters are not recognized                      }
  29. { o Write does not take care of window coordinates yet.              }
  30. { o Read does not recognize the special editing characters           }
  31. { o Read does not take care of window coordinates yet.               }
  32. { o Readkey extended scancode is not correct yet                     }
  33. { o Color mapping only works for 4 colours                           }
  34. { o ClrScr, DeleteLine, InsLine do not work with window coordinates  }
  35. {--------------------------------------------------------------------}
  36.  
  37.  
  38.  
  39. Interface
  40.  
  41. Const
  42. { Controlling consts }
  43.   Flushing=false;                       {if true then don't buffer output}
  44.   ScreenWidth  = 80;
  45.   ScreenHeight = 25;
  46.  
  47. { CRT modes }
  48.   BW40          = 0;            { 40x25 B/W on Color Adapter }
  49.   CO40          = 1;            { 40x25 Color on Color Adapter }
  50.   BW80          = 2;            { 80x25 B/W on Color Adapter }
  51.   CO80          = 3;            { 80x25 Color on Color Adapter }
  52.   Mono          = 7;            { 80x25 on Monochrome Adapter }
  53.   Font8x8       = 256;          { Add-in for ROM font }
  54.  
  55. { Mode constants for 3.0 compatibility }
  56.   C40           = CO40;
  57.   C80           = CO80;
  58.  
  59. {
  60.   When using this color constants on the Amiga
  61.   you can bet that they don't work as expected.
  62.   You never know what color the user has on
  63.   his Amiga. Perhaps we should do a check of
  64.   the number of bitplanes (for number of colors)
  65.  
  66.   The normal 4 first pens for an Amiga are
  67.  
  68.   0 LightGrey
  69.   1 Black
  70.   2 White
  71.   3 Blue
  72.  
  73. }
  74.  
  75. { Foreground and background color constants  }
  76.   Black         = 1;  { normal pen for amiga }
  77.   Blue          = 3;  { windowborder color   }
  78.   Green         = 15;
  79.   Cyan          = 7;
  80.   Red           = 4;
  81.   Magenta       = 5;
  82.   Brown         = 6;
  83.   LightGray     = 0;  { canvas color         }
  84.  
  85. { Foreground color constants }
  86.   DarkGray      = 8;
  87.   LightBlue     = 9;
  88.   LightGreen    = 10;
  89.   LightCyan     = 11;
  90.   LightRed      = 12;
  91.   LightMagenta  = 13;
  92.   Yellow        = 14;
  93.   White         = 2;  { third color on amiga }
  94.  
  95. { Add-in for blinking }
  96.   Blink         = 128;
  97.  
  98. {Other Defaults}
  99.   LastMode   : Word = 3;
  100.   WindMin    : Word = $0;
  101.   WindMax    : Word = $184f;
  102. { These don't change anything if they are modified }
  103.   CheckSnow  : Boolean = FALSE;
  104.   DirectVideo: Boolean = FALSE;
  105. var
  106.   TextAttr : BYTE;
  107.   { CheckBreak have to make this one to a function for Amiga }
  108.   CheckEOF : Boolean;
  109.  
  110. Procedure AssignCrt(Var F: Text);
  111. Function  KeyPressed: Boolean;
  112. Function  ReadKey: Char;
  113. Procedure TextMode(Mode: Integer);
  114. Procedure Window(X1, Y1, X2, Y2: BYTE);
  115. Procedure GoToXy(X: byte; Y: byte);
  116. Function  WhereX: Byte;
  117. Function  WhereY: Byte;
  118. Procedure ClrScr;
  119. Procedure ClrEol;
  120. Procedure InsLine;
  121. Procedure DelLine;
  122. Procedure TextColor(Color: Byte);
  123. Procedure TextBackground(Color: Byte);
  124. Procedure LowVideo;
  125. Procedure HighVideo;
  126. Procedure NormVideo;
  127. Procedure Delay(DTime: Word);
  128. Procedure Sound(Hz: Word);
  129. Procedure NoSound;
  130.  
  131. { Extra functions }
  132.  
  133. Procedure CursorOn;
  134. Procedure CursorOff;
  135. Function CheckBreak: Boolean;
  136.  
  137. Implementation
  138.  
  139. {
  140.   The definitions of TextRec and FileRec are in separate files.
  141. }
  142. {$i textrec.inc}
  143. {$i filerec.inc}
  144.  
  145. var
  146.   maxcols,maxrows : longint;
  147.  
  148. CONST
  149.   { This is used to make sure that readkey returns immediately }
  150.   { if keypressed was used beforehand.                         }
  151.   KeyPress : char = #0;
  152.   _LVODisplayBeep = -96;
  153.  
  154.  
  155. Type
  156.  
  157.     pInfoData = ^tInfoData;
  158.     tInfoData = packed record
  159.         id_NumSoftErrors        : Longint;      { number of soft errors on disk }
  160.         id_UnitNumber           : Longint;      { Which unit disk is (was) mounted on }
  161.         id_DiskState            : Longint;      { See defines below }
  162.         id_NumBlocks            : Longint;      { Number of blocks on disk }
  163.         id_NumBlocksUsed        : Longint;      { Number of block in use }
  164.         id_BytesPerBlock        : Longint;
  165.         id_DiskType             : Longint;      { Disk Type code }
  166.         id_VolumeNode           : Longint;         { BCPL pointer to volume node }
  167.         id_InUse                : Longint;      { Flag, zero if not in use }
  168.     end;
  169.  
  170. { *  List Node Structure.  Each member in a list starts with a Node * }
  171.  
  172.   pNode = ^tNode;
  173.   tNode = packed Record
  174.     ln_Succ,                { * Pointer to next (successor) * }
  175.     ln_Pred  : pNode;       { * Pointer to previous (predecessor) * }
  176.     ln_Type  : Byte;
  177.     ln_Pri   : Shortint;    { * Priority, for sorting * }
  178.     ln_Name  : PChar;       { * ID string, null terminated * }
  179.   End;  { * Note: Integer aligned * }
  180.  
  181. { normal, full featured list }
  182.  
  183.     pList = ^tList;
  184.     tList = packed record
  185.     lh_Head     : pNode;
  186.     lh_Tail     : pNode;
  187.     lh_TailPred : pNode;
  188.     lh_Type     : Byte;
  189.     l_pad       : Byte;
  190.     end;
  191.  
  192.     pMsgPort = ^tMsgPort;
  193.     tMsgPort = packed record
  194.     mp_Node     : tNode;
  195.     mp_Flags    : Byte;
  196.     mp_SigBit   : Byte;      { signal bit number    }
  197.     mp_SigTask  : Pointer;   { task to be signalled (TaskPtr) }
  198.     mp_MsgList  : tList;     { message linked list  }
  199.     end;
  200.  
  201.     pMessage = ^tMessage;
  202.     tMessage = packed record
  203.     mn_Node       : tNode;
  204.     mn_ReplyPort  : pMsgPort;   { message reply port }
  205.     mn_Length     : Word;       { message len in bytes }
  206.     end;
  207.  
  208.     pIOStdReq = ^tIOStdReq;
  209.     tIOStdReq = packed record
  210.     io_Message  : tMessage;
  211.     io_Device   : Pointer;      { device node pointer  }
  212.     io_Unit     : Pointer;      { unit (driver private)}
  213.     io_Command  : Word;         { device command }
  214.     io_Flags    : Byte;
  215.     io_Error    : Shortint;     { error or warning num }
  216.     io_Actual   : Longint;      { actual number of bytes transferred }
  217.     io_Length   : Longint;      { requested number bytes transferred}
  218.     io_Data     : Pointer;      { points to data area }
  219.     io_Offset   : Longint;      { offset for block structured devices }
  220.     end;
  221.  
  222.     pIntuiMessage = ^tIntuiMessage;
  223.     tIntuiMessage = packed record
  224.         ExecMessage     : tMessage;
  225.         IClass          : Longint;
  226.         Code            : Word;
  227.         Qualifier       : Word;
  228.         IAddress        : Pointer;
  229.         MouseX,
  230.         MouseY          : Word;
  231.         Seconds,
  232.         Micros          : Longint;
  233.         IDCMPWindow     : Pointer;
  234.         SpecialLink     : pIntuiMessage;
  235.     end;
  236.  
  237.     pWindow = ^tWindow;
  238.     tWindow = packed record
  239.         NextWindow      : pWindow;      { for the linked list in a screen }
  240.         LeftEdge,
  241.         TopEdge         : Integer;      { screen dimensions of window }
  242.         Width,
  243.         Height          : Integer;      { screen dimensions of window }
  244.         MouseY,
  245.         MouseX          : Integer;      { relative to upper-left of window }
  246.         MinWidth,
  247.         MinHeight       : Integer;      { minimum sizes }
  248.         MaxWidth,
  249.         MaxHeight       : Word;         { maximum sizes }
  250.         Flags           : Longint;      { see below for defines }
  251.         MenuStrip       : Pointer;      { the strip of Menu headers }
  252.         Title           : PChar;        { the title text for this window }
  253.         FirstRequest    : Pointer;      { all active Requesters }
  254.         DMRequest       : Pointer;      { double-click Requester }
  255.         ReqCount        : Integer;      { count of reqs blocking Window }
  256.         WScreen         : Pointer;      { this Window's Screen }
  257.         RPort           : Pointer;      { this Window's very own RastPort }
  258.         BorderLeft,
  259.         BorderTop,
  260.         BorderRight,
  261.         BorderBottom    : Shortint;
  262.         BorderRPort     : Pointer;
  263.         FirstGadget     : Pointer;
  264.         Parent,
  265.         Descendant      : pWindow;
  266.         Pointer_        : Pointer;      { sprite data }
  267.         PtrHeight       : Shortint;     { sprite height (not including sprite padding) }
  268.         PtrWidth        : Shortint;     { sprite width (must be less than or equal to 16) }
  269.         XOffset,
  270.         YOffset         : Shortint;     { sprite offsets }
  271.         IDCMPFlags      : Longint;      { User-selected flags }
  272.         UserPort,
  273.         WindowPort      : pMsgPort;
  274.         MessageKey      : pIntuiMessage;
  275.         DetailPen,
  276.         BlockPen        : Byte;         { for bar/border/gadget rendering }
  277.         CheckMark       : Pointer;
  278.         ScreenTitle     : PChar;        { if non-null, Screen title when Window is active }
  279.         GZZMouseX       : Integer;
  280.         GZZMouseY       : Integer;
  281.         GZZWidth        : Integer;
  282.         GZZHeight       : Word;
  283.         ExtData         : Pointer;
  284.         UserData        : Pointer;      { general-purpose pointer to User data extension }
  285.         WLayer          : Pointer;
  286.         IFont           : Pointer;
  287.         MoreFlags       : Longint;
  288.     end;
  289.  
  290.     const
  291.  
  292.     M_LNM               = 20;           { linefeed newline mode }
  293.     PMB_ASM     = M_LNM + 1;    { internal storage bit for AS flag }
  294.     PMB_AWM     = PMB_ASM + 1;  { internal storage bit for AW flag }
  295.     MAXTABS     = 80;
  296.     IECLASS_MAX = $15;
  297.  
  298. type
  299.  
  300.     pKeyMap = ^tKeyMap;
  301.     tKeyMap = packed record
  302.         km_LoKeyMapTypes        : Pointer;
  303.         km_LoKeyMap             : Pointer;
  304.         km_LoCapsable           : Pointer;
  305.         km_LoRepeatable         : Pointer;
  306.         km_HiKeyMapTypes        : Pointer;
  307.         km_HiKeyMap             : Pointer;
  308.         km_HiCapsable           : Pointer;
  309.         km_HiRepeatable         : Pointer;
  310.     end;
  311.  
  312.  
  313.  
  314.     pConUnit = ^tConUnit;
  315.     tConUnit = packed record
  316.         cu_MP   : tMsgPort;
  317.         { ---- read only variables }
  318.         cu_Window       : Pointer;      { (WindowPtr) intuition window bound to this unit }
  319.         cu_XCP          : Integer;        { character position }
  320.         cu_YCP          : Integer;
  321.         cu_XMax         : Integer;        { max character position }
  322.         cu_YMax         : Integer;
  323.         cu_XRSize       : Integer;        { character raster size }
  324.         cu_YRSize       : Integer;
  325.         cu_XROrigin     : Integer;        { raster origin }
  326.         cu_YROrigin     : Integer;
  327.         cu_XRExtant     : Integer;        { raster maxima }
  328.         cu_YRExtant     : Integer;
  329.         cu_XMinShrink   : Integer;        { smallest area intact from resize process }
  330.         cu_YMinShrink   : Integer;
  331.         cu_XCCP         : Integer;        { cursor position }
  332.         cu_YCCP         : Integer;
  333.  
  334.    { ---- read/write variables (writes must must be protected) }
  335.    { ---- storage for AskKeyMap and SetKeyMap }
  336.  
  337.         cu_KeyMapStruct : tKeyMap;
  338.  
  339.    { ---- tab stops }
  340.  
  341.         cu_TabStops     : Array [0..MAXTABS-1] of Word;
  342.                                 { 0 at start, -1 at end of list }
  343.  
  344.    { ---- console rastport attributes }
  345.  
  346.         cu_Mask         : Shortint;
  347.         cu_FgPen        : Shortint;
  348.         cu_BgPen        : Shortint;
  349.         cu_AOLPen       : Shortint;
  350.         cu_DrawMode     : Shortint;
  351.         cu_AreaPtSz     : Shortint;
  352.         cu_AreaPtrn     : Pointer;      { cursor area pattern }
  353.         cu_Minterms     : Array [0..7] of Byte; { console minterms }
  354.         cu_Font         : Pointer;      { (TextFontPtr) }
  355.         cu_AlgoStyle    : Byte;
  356.         cu_TxFlags      : Byte;
  357.         cu_TxHeight     : Word;
  358.         cu_TxWidth      : Word;
  359.         cu_TxBaseline   : Word;
  360.         cu_TxSpacing    : Word;
  361.  
  362.    { ---- console MODES and RAW EVENTS switches }
  363.  
  364.         cu_Modes        : Array [0..(PMB_AWM+7) div 8 - 1] of Byte;
  365.                                 { one bit per mode }
  366.         cu_RawEvents    : Array [0..(IECLASS_MAX+7) div 8 - 1] of Byte;
  367.     end;
  368.  
  369. const
  370.  
  371.  
  372.    CD_CURRX =  1;
  373.    CD_CURRY =  2;
  374.    CD_MAXX  =  3;
  375.    CD_MAXY  =  4;
  376.  
  377.    CSI      = chr($9b);
  378.  
  379.    SIGBREAKF_CTRL_C = 4096;
  380.  
  381. function AllocVec( size, reqm : Longint ): Pointer;
  382. begin
  383.    asm
  384.        MOVE.L  A6,-(A7)
  385.        MOVE.L  size,d0
  386.        MOVE.L  reqm,d1
  387.        MOVE.L  _ExecBase, A6
  388.        JSR -684(A6)
  389.        MOVE.L  (A7)+,A6
  390.        MOVE.L  d0,@RESULT
  391.    end;
  392. end;
  393.  
  394.  
  395. function DoPkt(ID : pMsgPort;
  396.                Action, Param1, Param2,
  397.                Param3, Param4, Param5 : Longint) : Longint;
  398. begin
  399.    asm
  400.        MOVEM.L d2/d3/d4/d5/d6/d7/a6,-(A7)
  401.        MOVE.L  ID,d1
  402.        MOVE.L  Action,d2
  403.        MOVE.L  Param1,d3
  404.        MOVE.L  Param2,d4
  405.        MOVE.L  Param3,d5
  406.        MOVE.L  Param4,d6
  407.        MOVE.L  Param5,d7
  408.        MOVE.L  _DOSBase,A6
  409.        JSR -240(A6)
  410.        MOVEM.L (A7)+,d2/d3/d4/d5/d6/d7/a6
  411.        MOVE.L  d0,@RESULT
  412.    end;
  413. end;
  414.  
  415. procedure FreeVec( memory : Pointer );
  416. begin
  417.    asm
  418.        MOVE.L  A6,-(A7)
  419.        MOVE.L  memory,a1
  420.        MOVE.L  _ExecBase,A6
  421.        JSR -690(A6)
  422.        MOVE.L  (A7)+,A6
  423.    end;
  424. end;
  425.  
  426.  
  427. function GetConsoleTask : pMsgPort;
  428. begin
  429.    asm
  430.        MOVE.L  A6,-(A7)
  431.        MOVE.L  _DOSBase,A6
  432.        JSR -510(A6)
  433.        MOVE.L  (A7)+,A6
  434.        MOVE.L  d0,@RESULT
  435.    end;
  436. end;
  437.  
  438.  
  439. function GetMsg(port : pMsgPort): pMessage;
  440. begin
  441.    asm
  442.        MOVE.L  A6,-(A7)
  443.        MOVE.L  port,a0
  444.        MOVE.L  _ExecBase,A6
  445.        JSR -372(A6)
  446.        MOVE.L  (A7)+,A6
  447.        MOVE.L  d0,@RESULT
  448.    end;
  449. end;
  450.  
  451. function ModifyIDCMP(window : pWindow;
  452.                      IDCMPFlags : Longint) : Boolean;
  453. begin
  454.    asm
  455.        MOVE.L  A6,-(A7)
  456.        MOVE.L  window,a0
  457.        MOVE.L  IDCMPFlags,d0
  458.        MOVE.L  _IntuitionBase,A6
  459.        JSR -150(A6)
  460.        MOVE.L  (A7)+,A6
  461.        TST.L   d0
  462.        bne     @success
  463.        bra     @end
  464.    @success:
  465.        move.b  #1,d0
  466.    @end:
  467.        move.b  d0,@RESULT
  468.    end;
  469. end;
  470.  
  471. procedure ReplyMsg(mess : pMessage);
  472. begin
  473.    asm
  474.        MOVE.L  A6,-(A7)
  475.        MOVE.L  mess,a1
  476.        MOVE.L  _ExecBase,A6
  477.        JSR -378(A6)
  478.        MOVE.L  (A7)+,A6
  479.    end;
  480. end;
  481.  
  482.  
  483. function WaitPort(port : pMsgPort): pMessage;
  484. begin
  485.    asm
  486.        MOVE.L  A6,-(A7)
  487.        MOVE.L  port,a0
  488.        MOVE.L  _ExecBase,A6
  489.        JSR -384(A6)
  490.        MOVE.L  (A7)+,A6
  491.        MOVE.L  d0,@RESULT
  492.    end;
  493. end;
  494.  
  495. procedure Delay_(ticks : Longint);
  496. begin
  497.    asm
  498.        MOVE.L  A6,-(A7)
  499.        MOVE.L  ticks,d1
  500.        MOVE.L  _DOSBase,A6
  501.        JSR -198(A6)
  502.        MOVE.L  (A7)+,A6
  503.    end;
  504. end;
  505.  
  506. function SetSignal(newSignals, signalMask : Longint) : Longint;
  507. begin
  508.    asm
  509.        MOVE.L  A6,-(A7)
  510.        MOVE.L  newSignals,d0
  511.        MOVE.L  signalMask,d1
  512.        MOVE.L  _ExecBase,A6
  513.        JSR -306(A6)
  514.        MOVE.L  (A7)+,A6
  515.        MOVE.L  d0,@RESULT
  516.    end;
  517. end;
  518.  
  519. function OpenInfo : pInfoData;
  520. var
  521.    port     :  pMsgPort;
  522.    info     :  pInfoData;
  523.    bptr, d4, d5, d6, d7 :  Longint;
  524. begin
  525.    info  := pInfoData(AllocVec(SizeOf(tInfoData), 1));
  526.  
  527.    if info <> nil then begin
  528.       port  := GetConsoleTask;
  529.       bptr  := Longint(info) shr 2;
  530.  
  531.       if port <> nil then begin
  532.          if DoPkt(port, $19, bptr, d4, d5, d6, d7) <> 0 then info := pInfoData(bptr shl 2)
  533.          else port := nil;
  534.       end;
  535.  
  536.       if port = nil then begin
  537.          FreeVec(info);
  538.          info := nil;
  539.       end;
  540.    end;
  541.  
  542.    OpenInfo := info;
  543. end;
  544.  
  545. procedure CloseInfo(var info : pInfoData);
  546. begin
  547.    if info <> nil then begin
  548.       FreeVec(info);
  549.       info := nil;
  550.    end;
  551. end;
  552.  
  553. function ConData(modus : byte) : integer;
  554. var
  555.    info  :  pInfoData;
  556.    theunit  :  pConUnit;
  557.    pos   :  Longint;
  558. begin
  559.    pos   := 1;
  560.    info  := OpenInfo;
  561.  
  562.    if info <> nil then begin
  563.       theunit  := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit);
  564.  
  565.       case modus of
  566.          CD_CURRX :  pos   := theunit^.cu_XCP;
  567.          CD_CURRY :  pos   := theunit^.cu_YCP;
  568.          CD_MAXX  :  pos   := theunit^.cu_XMax;
  569.          CD_MAXY  :  pos   := theunit^.cu_YMax;
  570.       end;
  571.  
  572.       CloseInfo(info);
  573.    end;
  574.  
  575.    ConData := pos + 1;
  576. end;
  577.  
  578. function WhereX : Byte;
  579. begin
  580.    WhereX := Byte(ConData(CD_CURRX))-lo(windmin);
  581. end;
  582.  
  583. function realx: byte;
  584. begin
  585.    RealX := Byte(ConData(CD_CURRX));
  586. end;
  587.  
  588. function realy: byte;
  589. begin
  590.  RealY := Byte(ConData(CD_CURRY));
  591. end;
  592.  
  593. function WhereY : Byte;
  594. begin
  595.    WhereY := Byte(ConData(CD_CURRY))-hi(windmin);
  596. end;
  597.  
  598. function screencols : integer;
  599. begin
  600.    screencols := ConData(CD_MAXX);
  601. end;
  602.  
  603. function screenrows : integer;
  604. begin
  605.    screenrows := ConData(CD_MAXY);
  606. end;
  607.  
  608.  
  609.  procedure Realgotoxy(x,y : integer);
  610.  begin
  611.        Write(CSI, y, ';', x, 'H');
  612.  end;
  613.  
  614.  
  615.  procedure gotoxy(x,y : byte);
  616.  begin
  617.         if (x<1) then
  618.           x:=1;
  619.         if (y<1) then
  620.           y:=1;
  621.         if y+hi(windmin)-2>=hi(windmax) then
  622.           y:=hi(windmax)-hi(windmin)+1;
  623.         if x+lo(windmin)-2>=lo(windmax) then
  624.           x:=lo(windmax)-lo(windmin)+1;
  625.         Write(CSI, y+hi(windmin), ';', x+lo(windmin), 'H');
  626.  end;
  627.  
  628.  
  629. procedure CursorOff;
  630. begin
  631.    Write(CSI,'0 p');
  632. end;
  633.  
  634. procedure CursorOn;
  635. begin
  636.    Write(CSI,'1 p');
  637. end;
  638.  
  639. procedure ClrScr;
  640. begin
  641.    Write(Chr($0c));
  642. end;
  643.  
  644. function ReadKey : char;
  645. const
  646.    IDCMP_VANILLAKEY = $00200000;
  647.    IDCMP_RAWKEY     = $00000400;
  648. var
  649.    info  :  pInfoData;
  650.    win   :  pWindow;
  651.    imsg  :  pIntuiMessage;
  652.    msg   :  pMessage;
  653.    key   :  char;
  654.    idcmp, vanil   :  Longint;
  655. begin
  656.    key   := #0;
  657.    if KeyPress <> #0 then
  658.     Begin
  659.       ReadKey:=KeyPress;
  660.       KeyPress:=#0;
  661.       exit;
  662.     end;
  663.    info  := OpenInfo;
  664.  
  665.    if info <> nil then begin
  666.       win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
  667.       idcmp := win^.IDCMPFlags;
  668.       vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
  669.  
  670.       ModifyIDCMP(win, (idcmp or vanil));
  671.  
  672.       repeat
  673.          msg   := WaitPort(win^.UserPort);
  674.          imsg  := pIntuiMessage(GetMsg(win^.UserPort));
  675.  
  676.          if (imsg^.IClass = IDCMP_VANILLAKEY) then
  677.               key := char(imsg^.Code)
  678.          else
  679.          if (imsg^.IClass = IDCMP_RAWKEY) then
  680.               key := char(imsg^.Code);
  681.  
  682.          ReplyMsg(pMessage(imsg));
  683.       until key <> #0;
  684.  
  685.       repeat
  686.          msg   := GetMsg(win^.UserPort);
  687.  
  688.          if msg <> nil then ReplyMsg(msg);
  689.       until msg = nil;
  690.  
  691.       ModifyIDCMP(win, idcmp);
  692.  
  693.       CloseInfo(info);
  694.    end;
  695.  
  696.    ReadKey := key;
  697. end;
  698.  
  699. function KeyPressed : Boolean;
  700. const
  701.    IDCMP_VANILLAKEY = $00200000;
  702.    IDCMP_RAWKEY     = $00000400;
  703. var
  704.    info  :  pInfoData;
  705.    win   :  pWindow;
  706.    imsg  :  pIntuiMessage;
  707.    msg   :  pMessage;
  708.    idcmp, vanil   :  Longint;
  709.    ispressed : Boolean;
  710. begin
  711.    KeyPress := #0;
  712.    ispressed := False;
  713.    info  := OpenInfo;
  714.  
  715.    if info <> nil then begin
  716.       win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
  717.       idcmp := win^.IDCMPFlags;
  718.       vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
  719.  
  720.       ModifyIDCMP(win, (idcmp or vanil));
  721.  
  722.       msg   := WaitPort(win^.UserPort);
  723.       imsg  := pIntuiMessage(GetMsg(win^.UserPort));
  724.  
  725.       if (imsg^.IClass = IDCMP_VANILLAKEY) or (imsg^.IClass = IDCMP_RAWKEY) then
  726.       Begin
  727.         ispressed := true;
  728.         KeyPress := char(imsg^.Code)
  729.       end;
  730.  
  731.       ReplyMsg(pMessage(imsg));
  732.  
  733.       repeat
  734.          msg   := GetMsg(win^.UserPort);
  735.  
  736.          if msg <> nil then ReplyMsg(msg);
  737.       until msg = nil;
  738.  
  739.       ModifyIDCMP(win, idcmp);
  740.  
  741.       CloseInfo(info);
  742.    end;
  743.  
  744.    KeyPressed := ispressed;
  745. end;
  746.  
  747. procedure TextColor(color : byte);
  748. begin
  749.    TextAttr := (TextAttr and $70) or color;
  750.    Write(CSI, '3', color, 'm');
  751. end;
  752.  
  753. procedure TextBackground(color : byte);
  754. begin
  755.    Textattr:=(textattr and $8f) or ((color and $7) shl 4);
  756.    Write(CSI, '4', color, 'm');
  757. end;
  758.  
  759. procedure Window(X1,Y1,X2,Y2: Byte);
  760.  begin
  761.    if (x1<1) or (x2>screencols) or (y2>screenrows) or
  762.      (x1>x2) or (y1>y2) then
  763.        exit;
  764.    windmin:=(x1-1) or ((y1-1) shl 8);
  765.    windmax:=(x2-1) or ((y2-1) shl 8);
  766.    gotoxy(1,1);
  767.  end;
  768.  
  769.  
  770.  
  771.  
  772.  
  773. procedure DelLine;
  774. begin
  775.    Write(CSI,'M');
  776. end;
  777.  
  778. procedure ClrEol;
  779. begin
  780.    Write(CSI,'K');
  781. end;
  782.  
  783. procedure InsLine;
  784. begin
  785.    Write(CSI,'L');
  786. end;
  787.  
  788. procedure cursorbig;
  789. begin
  790. end;
  791.  
  792. procedure lowvideo;
  793. begin
  794. end;
  795.  
  796. procedure highvideo;
  797. begin
  798. end;
  799.  
  800. procedure nosound;
  801. begin
  802. end;
  803.  
  804. procedure sound(hz : word);
  805. begin
  806. end;
  807.  
  808. procedure delay(DTime : Word);
  809. var
  810.     dummy : Longint;
  811. begin
  812.     dummy := trunc((real(DTime) / 1000.0) * 50.0);
  813.     Delay_(dummy);
  814. end;
  815.  
  816. function CheckBreak : boolean;
  817. begin
  818.    if (SetSignal(0, 0) and SIGBREAKF_CTRL_C) = SIGBREAKF_CTRL_C then
  819.       CheckBreak := true
  820.    else
  821.       CheckBreak := false;
  822. end;
  823.  
  824. procedure textmode(mode : integer);
  825. begin
  826.        lastmode:=mode;
  827.        mode:=mode and $ff;
  828.        windmin:=0;
  829.        windmax:=(screencols-1) or ((screenrows-1) shl 8);
  830.        maxcols:=screencols;
  831.        maxrows:=screenrows;
  832. end;
  833.  
  834. procedure normvideo;
  835. begin
  836. end;
  837.  
  838. function GetTextBackground : byte;
  839. var
  840.    info  :  pInfoData;
  841.    pen   :  byte;
  842. begin
  843.    pen   := 1;
  844.    info  := OpenInfo;
  845.  
  846.    if info <> nil then begin
  847.       pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_BgPen;
  848.  
  849.       CloseInfo(info);
  850.    end;
  851.  
  852.    GetTextBackground := pen;
  853. end;
  854.  
  855. function GetTextColor : byte;
  856. var
  857.    info  :  pInfoData;
  858.    pen   :  byte;
  859. begin
  860.    pen   := 1;
  861.    info  := OpenInfo;
  862.  
  863.    if info <> nil then begin
  864.       pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_FgPen;
  865.  
  866.       CloseInfo(info);
  867.    end;
  868.  
  869.    GetTextColor   := pen;
  870. end;
  871.  
  872.  
  873. {*****************************************************************************
  874.                           Read and Write routines
  875. *****************************************************************************}
  876. { Problem here: Currently all these routines are not implemented because of how }
  877. { the console device works. Because w low level write is required to change the }
  878. { position of the cursor, and since the CrtWrite is assigned as the standard    }
  879. { write routine, a recursive call will occur                                    }
  880.  
  881. { How to fix this:                                                              }
  882. {  At startup make a copy of the Output handle, and then use this copy to make  }
  883. {  low level positioning calls. This does not seem to work yet.                 }
  884.  
  885.  
  886.  
  887.    Function CrtWrite(var f : textrec):integer;
  888.  
  889.       var
  890.          i,col,row : longint;
  891.          c : char;
  892.          buf: array[0..1] of char;
  893.  
  894.       begin
  895.          col:=realx;
  896.          row:=realy;
  897.          inc(row);
  898.          inc(col);
  899.          for i:=0 to f.bufpos-1 do
  900.            begin
  901.               c:=f.buffer[i];
  902.               case ord(c) of
  903.                  10 : begin
  904.                          inc(row);
  905.                       end;
  906.                  13 : begin
  907.                          col:=lo(windmin)+1;
  908.                      end;
  909.                  8 : if col>lo(windmin)+1 then
  910.                        begin
  911.                           dec(col);
  912.                        end;
  913.                  7 : begin
  914.                          { beep }
  915.                          asm
  916.                            move.l a6,d6               { save base pointer    }
  917.                            move.l _IntuitionBase,a6   { set library base     }
  918.                            sub.l  a0,a0
  919.                            jsr    _LVODisplayBeep(a6)
  920.                            move.l d6,a6               { restore base pointer }
  921.                          end;
  922.                       end;
  923.               else
  924.                  begin
  925.                    buf[0]:=c;
  926.                    realgotoxy(row,col);
  927.                    do_write(f.handle,longint(@buf[0]),1);
  928.                    inc(col);
  929.                  end;
  930.               end;
  931.               if col>lo(windmax)+1 then
  932.                 begin
  933.                    col:=lo(windmin)+1;
  934.                    inc(row);
  935.                 end;
  936.               while row>hi(windmax)+1 do
  937.                 begin
  938.                    delline;
  939.                    dec(row);
  940.                 end;
  941.            end;
  942.          f.bufpos:=0;
  943.          realgotoxy(row-1,col-1);
  944.          CrtWrite:=0;
  945.       end;
  946.  
  947.    Function CrtClose(Var F: TextRec): Integer;
  948.      Begin
  949.        F.Mode:=fmClosed;
  950.        CrtClose:=0;
  951.      End;
  952.  
  953.    Function CrtOpen(Var F: TextRec): Integer;
  954.      Begin
  955.        If F.Mode = fmOutput Then
  956.         CrtOpen:=0
  957.        Else
  958.         CrtOpen:=5;
  959.      End;
  960.  
  961.    Function CrtRead(Var F: TextRec): Integer;
  962.      Begin
  963.        f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);
  964.        f.bufpos:=0;
  965.        CrtRead:=0;
  966.      End;
  967.  
  968.    Function CrtInOut(Var F: TextRec): Integer;
  969.      Begin
  970.        Case F.Mode of
  971.         fmInput: CrtInOut:=CrtRead(F);
  972.         fmOutput: CrtInOut:=CrtWrite(F);
  973.        End;
  974.      End;
  975.  
  976.    procedure assigncrt(var f : text);
  977.      begin
  978.    {     TextRec(F).Mode:=fmClosed;
  979.         TextRec(F).BufSize:=SizeOf(TextBuf);
  980.         TextRec(F).BufPtr:=@TextRec(F).Buffer;
  981.         TextRec(F).BufPos:=0;
  982.         TextRec(F).OpenFunc:=@CrtOpen;
  983.         TextRec(F).InOutFunc:=@CrtInOut;
  984.         TextRec(F).FlushFunc:=@CrtInOut;
  985.         TextRec(F).CloseFunc:=@CrtClose;
  986.         TextRec(F).Name[0]:='.';
  987.         TextRec(F).Name[1]:=#0;}
  988.      end;
  989.  
  990.  
  991. var
  992.   old_exit : pointer;
  993.  
  994. procedure crt_exit;
  995. begin
  996.   { Restore default colors }
  997.   write(CSI,'0m');
  998.   exitproc:=old_exit;
  999. end;
  1000.  
  1001.  
  1002. Begin
  1003.    old_exit:=exitproc;
  1004.    exitproc:=@crt_exit;
  1005.    { load system variables to temporary variables to save time }
  1006.    maxcols:=screencols;
  1007.    maxrows:=screenrows;
  1008.    { Set the initial text attributes }
  1009.    { Text background }
  1010.    Textattr:=(textattr and $8f) or ((GetTextBackGround and $7) shl 4);
  1011.    { Text foreground }
  1012.    TextAttr := (TextAttr and $70) or GetTextColor;
  1013.    { set output window }
  1014.    windmax:=(maxcols-1) or (( maxrows-1) shl 8);
  1015.  
  1016.  
  1017.    { Get a copy of the standard      }
  1018.    { output handle, and when using   }
  1019.    { direct console calls, use this  }
  1020.    { handle instead.                 }
  1021. {   assigncrt(Output);
  1022.    TextRec(Output).mode:=fmOutput;}
  1023. end.
  1024.  
  1025.  
  1026.  
  1027.  
  1028.  
  1029.